home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / FONTEDIT.ZIP / FONTEDK.PAS < prev    next >
Pascal/Delphi Source File  |  1995-12-23  |  4KB  |  194 lines
  1. {A BUNCH OF SLAP HAPPY CODING TO GET IT TO WORK ANY WAY RUSHED JOB 20.12.95}
  2.  
  3. Uses Mcga,Crt;
  4. Const
  5.      Open : Boolean = False;
  6.      PenOn : Boolean = True;
  7.  
  8. Var
  9.    Grid : Array[1..16,1..16] Of Byte;
  10.    X,Y,Z,col,start : Byte;
  11.    Xpos,Ypos : Byte;
  12.    Block : String[1];
  13.    ch : Char;
  14.    F : Text;
  15.  
  16.  
  17. Procedure SetGrid;
  18. Begin
  19.      For X := 1 To 16 Do
  20.      For Y := 1 To 16 Do
  21.      Begin
  22.           TextColor(15); Gotoxy(X,Y);
  23.           If Grid[X,Y] = 0 Then Write('+') Else Begin
  24.           TextColor(Grid[X,Y]); Write('█'); end;
  25.      end;
  26.      Col := 1; GotoXy(Xpos,Ypos);
  27. end;
  28.  
  29. Procedure WriteIt;
  30. Begin
  31.      Write(Block);
  32.      Grid[Xpos,Ypos] := Col;
  33. end;
  34.  
  35. Procedure Down;
  36. Begin
  37.      Inc(Ypos);
  38.      Gotoxy(Xpos,Ypos);
  39.      If PenOn Then WriteIt;
  40. end;
  41.  
  42. Procedure Up;
  43. Begin
  44.      Dec(Ypos);
  45.      Gotoxy(Xpos,Ypos);
  46.      If PenOn Then WriteIt;
  47. end;
  48.  
  49. Procedure Left;
  50. Begin
  51.      Dec(Xpos);
  52.      Gotoxy(Xpos,Ypos);
  53.      If PenOn Then WriteIt;
  54. end;
  55.  
  56. Procedure Right;
  57. Begin
  58.      Inc(Xpos);
  59.      Gotoxy(Xpos,Ypos);
  60.      If PenOn Then WriteIt;
  61. end;
  62.  
  63.  
  64. Procedure SaveIt;
  65. Begin
  66.      If Not Open Then Assign(F,ParamStr(1));
  67.      If Not Open Then Rewrite(F);
  68.      Open := True;
  69.  
  70.      Writeln(F,'Const E : Array[1..16,1..16] Of Byte =');
  71.  
  72.      For Y := 1 To 16 Do Begin
  73.      For X := 1 To 16 Do Begin
  74.  
  75.      If (Z = 1) And (Start = 1) Then Write(F,'((',Grid[X,Y],',') else
  76.      If Z = 1 Then Write(F,'(',Grid[X,Y],',') else
  77.      If (Z = 16) Then Write(F,Grid[X,Y],'),') else
  78.      Write(F,Grid[X,Y],',');
  79.      Inc(Start);
  80.  
  81.      Inc(Z);
  82.      If Z = 17 Then
  83.      Begin
  84.           Z := 1;
  85.           Writeln(f);
  86.      end;
  87. end;
  88. end;
  89.  
  90.     Writeln(F);
  91.     Start := 1;
  92. end;
  93.  
  94.  
  95. Procedure Show;
  96. Begin
  97.      Gmode;
  98.      For Y := 1 To 16 Do
  99.      For X := 1 To 16 Do
  100.      If Grid[X,Y] <> 0 then PutPixel(X,Y,Grid[X,Y],VGA);
  101.      Readkey;
  102.      Tmode;
  103.      SetGrid;
  104. end;
  105.  
  106. Procedure Help;
  107. Begin
  108.      TextColor(15);
  109.      Gotoxy(20,12); Write('Number 1 To 8 Change Color 0 = Reset');
  110.      Gotoxy(20,11); Write('ENTER Show Graphical Font (Pallette Not Set');
  111.      Gotoxy(20,13); Write('Use Cursors To Move Pointer');
  112.      Gotoxy(20,14); Write('Space PenUp Or PenDown');
  113.      TextColor(Col);
  114. end;
  115.  
  116.  
  117. Procedure NewFont;
  118. Begin
  119.      SaveIt;
  120.      For X := 1 To 16 Do
  121.      For Y := 1 To 16 Do
  122.      Grid[X,Y] := 0;
  123.      TextColor(15);
  124.      Gotoxy(1,1); Xpos := 1; Ypos := 1;
  125.      SetGrid;
  126. end;
  127.  
  128.  
  129. Begin
  130.      Start := 1; Xpos := 1; Ypos := 1; Block := '█';
  131.      If ParamCount < 1 Then
  132.      Begin
  133.           Writeln('Please Specify A Filename To Save To');
  134.           Writeln('e.g Fonted C:\A.Fnt');
  135.           Halt;
  136.      end;
  137.  
  138.      ClrScr;
  139.      Writeln('Font Editor By Darius Sutherland Crucial D');
  140.      Writeln('Very Basic But Can Produce 16x16 Fonts');
  141.      Writeln('Fonts Depend On Creative Skill');
  142.      Writeln;
  143.      Writeln('Press Q Any Time For Help');
  144.      Readkey;
  145.      Clrscr;
  146.  
  147.      Z := 1;
  148.      For X := 1 To 16 Do
  149.      For Y := 1 To 16 Do
  150.          Grid[X,Y] := 0;
  151.          SetGrid;
  152.          Gotoxy(Xpos,Ypos);
  153.          TextColor(Col);
  154.  
  155.          REPEAT
  156.  
  157.          Ch := Readkey;
  158.  
  159.          If Ch = '1' Then Col := 1;
  160.          If Ch = '2' Then Col := 2;
  161.          If Ch = '3' Then Col := 3;
  162.          If Ch = '4' Then col := 4;
  163.          If Ch = '5' Then Col := 5;
  164.          If Ch = '6' Then Col := 6;
  165.          If Ch = '7' Then Col := 7;
  166.          If Ch = '8' Then Col := 8;
  167.          If Ch = '0' Then Col := 0;
  168.          If (Ch = 'Q') Or (Ch = 'q') Then Help;
  169.          If Col = 0 Then Block := '+' else Block := '█';
  170.          If (Ch = #80) And (Ypos < 16) Then Down;
  171.          If (Ch = #72) And (Ypos > 1) Then Up;
  172.          If (Ch = #75) And (Xpos > 1) then Left;
  173.          If (Ch = #77) And (Xpos < 16) Then Right;
  174.          If (Ch = 'n') Or (Ch = 'N') Then NewFont;
  175.          If Ch = #13 Then Show;
  176.          If Ch = #32 Then
  177.          Begin
  178.               PenOn := Not PenOn;
  179.          end;
  180.          If Col = 0 Then TextColor(15) else TextColor(Col);
  181.  
  182.          UNTIL Ch = #27;
  183.  
  184.     SaveIt;
  185.     If Open Then Close(f);
  186.     TextColor(15);
  187.     TextBackGround(0);
  188.     Clrscr;
  189.     Writeln('Font Editor By Darius Sutherland Crucial D');
  190.     Writeln('All Fonts Save To File');
  191.     Writeln;
  192.     Writeln('18.12.95');
  193. end.
  194.